{
  Created by Alexander Larkin

  E-mail:                  larkin@titov.msk.ru
  Internet address:        http://www.geocities.com/SiliconValley/6235/
}


{$M 64000,160000,160000}
program AVLLNG;

uses Graph,crt;

const maxmcr=120;
      drawing: boolean=true;

var
 erris: boolean;
 bg: pointer;

 grDriver: Integer;
 grMode: Integer;
 ErrCode: Integer;

 ReadFromFile: string;
 StringNumber: longint;

 SavedMacroses: array[0..maxmcr,0..1] of string;
 LastMacro: word;

 ti: boolean;

 DegreeAngle: integer;
 oldx,oldy,x,y: real;

 MacroName,StrValue: string;
 LngValue: longint;
 ValError: integer;
 Command: string;
 CommandDone: boolean;

 s,WrkStrNow: string;
 drwcan: boolean;

function st(w: longint): string;
var s: string;
begin
 str(w,s);
 st:=s;
end;

function strr(r: real): string;
var s: string;
begin
 str(r:5:3,s);
 strr:=s;
end;

procedure AvlLngError(b: byte; s: string);
var s1,errmsg: string;
begin
  case b of
   1: errmsg:='Unknown command "'+s+'"';
   2: errmsg:='Name "'+s+'" already used';
   3: errmsg:='Macros overflow! Cannot add macros.';
   4: errmsg:=s;
  end;
   SetFillStyle(1,black);
   Bar (1,420,640,460);
if b<>4 then
begin
     outtextxy(1,420,'Error happened at user command number '+st(StringNumber) );
     outtextxy(1,440,ReadFromFile);
     s1:=ReadFromFile;
     delete(s1,1,length(WrkStrNow));
     outtextxy(TextWidth(s1),448,'^'+errmsg);
     ErrIs:=true;
end else outtextxy(1,448,'^'+errmsg);
end;

procedure clear_turtle;
begin
if ti then
 begin
  putimage(round(x)-15,round(y)-15,bg^,normalput);
  ti:=false;
 end;
end;

var x1,y1,x2,y2,x3,y3: real;

procedure draw_turtle;
begin
ti:=false;
if (x-15>0) and (x-15<640) and (y-15>0) and (y-15<400) and
   (x+15>0) and (x+15<640) and (y+15>0) and (y+15<400) and (ti=false) then
begin
ti:=true;
getimage(round(x)-15,round(y)-15,round(x)+15,round(y)+15,bg^);
setcolor(14);
x1:=cos(DegreeAngle/(180/pi))*10+x;
y1:=sin(DegreeAngle/(180/pi))*10+y;
x2:=-cos((DegreeAngle+15)/(180/pi))*12+x1;
y2:=-sin((DegreeAngle+15)/(180/pi))*12+y1;
x3:=-cos((DegreeAngle-15)/(180/pi))*12+x1;
y3:=-sin((DegreeAngle-15)/(180/pi))*12+y1;
if (x1>0) and (x1<640) and (y1>0) and (y1<400) and
   (x2>0) and (x2<640) and (y2>0) and (y2<400) then
   line(Round(x1),Round(y1),Round(x2),Round(y2));
if (x1>0) and (x1<640) and (y1>0) and (y1<400) and
   (x3>0) and (x3<640) and (y3>0) and (y3<400) then
   line(Round(x1),Round(y1),Round(x3),Round(y3));
setcolor(15);
end;
end;

procedure docommand(cw: string);
var l: longint;
    i: integer;
    xwas,ywas: real;
    wrkstr: string;
    drwwas: boolean;
    anglwas: integer;
begin
if erris then exit;
WrkStrNow:=cw;
CommandDone:=false;

{Work with "macro" command}
wrkstr:=cw;
Command:=wrkstr;
delete(Command,6,length(Command)-5);
  if (Command='macro') and (CommandDone=false) then
   begin
    delete(wrkstr,1,5);
    while (wrkstr[1] in[' ']) and (length(wrkstr)>0) do delete(wrkstr,1,1);
    MacroName:='';
    while (not (wrkstr[1] in[' ','='])) and (length(wrkstr)>0) do
     begin
      MacroName:=MacroName+wrkstr[1];
      delete(wrkstr,1,1);
     end;
    while (wrkstr[1] in[' ','=',':']) and (length(wrkstr)>0) do delete(wrkstr,1,1);

    for i:=0 to LastMacro-1 do
    if (MacroName=SavedMacroses[i,0]) or
        (MacroName='left') or
        (MacroName='right') or
        (MacroName='down') or
        (MacroName='macro') or
        (MacroName='repeat') or
        (MacroName='forward') then
     begin
      delete(WrkStrNow,1,5);
      while (wrkstrnow[1] in[' ','=',':']) and (length(wrkstrnow)>0) do delete(wrkstrnow,1,1);
      AvlLngError(2,MacroName);
     end;

    if LastMacro>MaxMcr-2 then AvlLngError(3,MacroName);


    if erris=false then
    begin
    SavedMacroses[LastMacro,0]:=MacroName;
    SavedMacroses[LastMacro,1]:=wrkstr;
    drwwas:=drawing;
    drawing:=false;
    xwas:=x;
    ywas:=y;
    anglwas:=DegreeAngle;
    drwcan:=false;
    docommand(wrkstr);
    drwcan:=true;
    x:=xwas;
    y:=ywas;
    DegreeAngle:=anglwas;
    drawing:=drwwas;
    LastMacro:=LastMacro+1;
    end;
    CommandDone:=true;
   end;

wrkstr:=cw;
Command:=wrkstr;
delete(Command,7,length(Command)-6);
  if (Command='repeat') and (CommandDone=false) then
    begin
     delete(wrkstr,1,6);
     while (not (wrkstr[1] in['0'..'9'])) and (length(wrkstr)>0) do delete(wrkstr,1,1);
     StrValue:='';
     while (wrkstr[1] in['0'..'9']) and (length(wrkstr)>0) do
      begin
       StrValue:=StrValue+wrkstr[1];
       delete(wrkstr,1,1);
      end;
     val(StrValue,LngValue,i);
     while (wrkstr[1] in[' ','=']) and (length(wrkstr)>0) do delete(wrkstr,1,1);
     for l:=1 to LngValue do docommand(wrkstr);
     CommandDone:=true;
    end;

wrkstr:=cw;
Command:=wrkstr;
delete(Command,5,length(Command)-4);
if (Command='left') and (CommandDone=false) then
    begin
     delete(wrkstr,1,4);
     while (not (wrkstr[1] in['0'..'9'])) and (length(wrkstr)>0) do delete(wrkstr,1,1);
     StrValue:='';
     while (wrkstr[1] in['0'..'9']) and (length(wrkstr)>0) do
      begin
       StrValue:=StrValue+wrkstr[1];
       delete(wrkstr,1,1);
      end;
     val(StrValue,LngValue,ValError);
     if drwcan then clear_turtle;
     DegreeAngle:=DegreeAngle-LngValue;
     DegreeAngle:=DegreeAngle mod 360;
     if DegreeAngle<0 then DegreeAngle:=360+DegreeAngle;
     if drwcan then draw_turtle;
     while (wrkstr[1] in[' ','=',':']) and (length(wrkstr)>0) do delete(wrkstr,1,1);
     if length(wrkstr)>0 then docommand(wrkstr);
     CommandDone:=true;
    end;

wrkstr:=cw;
Command:=wrkstr;
delete(Command,6,length(Command)-5);
if (Command='right') and (CommandDone=false) then
    begin
     delete(wrkstr,1,5);
     while (not (wrkstr[1] in['0'..'9'])) and (length(wrkstr)>0) do delete(wrkstr,1,1);
     StrValue:='';
     while (wrkstr[1] in['0'..'9']) and (length(wrkstr)>0) do
      begin
       StrValue:=StrValue+wrkstr[1];
       delete(wrkstr,1,1);
      end;
     val(StrValue,LngValue,ValError);
     if drwcan then clear_turtle;
     DegreeAngle:=DegreeAngle+LngValue;
     DegreeAngle:=DegreeAngle mod 360;
     if DegreeAngle<0 then DegreeAngle:=360-DegreeAngle;
     if drwcan then draw_turtle;
     while (wrkstr[1] in[' ','=',':']) and (length(wrkstr)>0) do delete(wrkstr,1,1);
     if length(wrkstr)>0 then docommand(wrkstr);
     CommandDone:=true;
    end;

wrkstr:=cw;
Command:=wrkstr;
delete(Command,8,length(Command)-7);
if (Command='forward') and (CommandDone=false) then
    begin
     delete(wrkstr,1,7);
     while (not (wrkstr[1] in['0'..'9'])) and (length(wrkstr)>0) do delete(wrkstr,1,1);
     StrValue:='';
     while (wrkstr[1] in['0'..'9']) and (length(wrkstr)>0) do
      begin
       StrValue:=StrValue+wrkstr[1];
       delete(wrkstr,1,1);
      end;
     val(StrValue,LngValue,ValError);
     if drwcan then clear_turtle;
     oldx:=x;
     oldy:=y;
     x:=x+cos(DegreeAngle/(180/pi))*LngValue;
     y:=y+sin(DegreeAngle/(180/pi))*LngValue;
     setcolor(15);
     if drwcan and drawing then
     if (oldx>0) and (oldx<640) and (oldy>0) and (oldy<400) and
        (x>0) and (x<640) and (y>0) and (y<400) then
        line(round(oldx),round(oldy),round(x),round(y));
     if drwcan then draw_turtle;
     while (wrkstr[1] in[' ','=',':']) and (length(wrkstr)>0) do delete(wrkstr,1,1);
     if length(wrkstr)>0 then docommand(wrkstr);
     CommandDone:=true;
    end;

wrkstr:=cw;
Command:=wrkstr;
delete(Command,5,length(Command)-4);
if (Command='down') and (CommandDone=false) then
    begin
     drawing:=true;
     delete(wrkstr,1,4);
     while (wrkstr[1] in[' ','=',':']) and (length(wrkstr)>0) do delete(wrkstr,1,1);
     if length(wrkstr)>0 then docommand(wrkstr);
     CommandDone:=true;
    end;

wrkstr:=cw;
Command:=wrkstr;
delete(Command,3,length(Command)-2);
if (Command='up') and (CommandDone=false) then
    begin
     drawing:=false;
     delete(wrkstr,1,2);
     while (wrkstr[1] in[' ','=',':']) and (length(wrkstr)>0) do delete(wrkstr,1,1);
     if length(wrkstr)>0 then docommand(wrkstr);
     CommandDone:=true;
    end;

Command:='';
wrkstr:=cw;
while (not (wrkstr[1] in[' ','=',':'])) and (length(wrkstr)>0) do
 begin
  Command:=Command+wrkstr[1];
  delete(wrkstr,1,1);
 end;
wrkstr:=cw;
for i:=0 to LastMacro-1 do if (Command=SavedMacroses[i,0]) and (CommandDone=false) then
 begin
  delete(wrkstr,1,length(Command));
  while (wrkstr[1] in[' ','=',':']) and (length(wrkstr)>0) do delete(wrkstr,1,1);
  docommand(SavedMacroses[i,1]);
  while (wrkstr[1] in[' ','=']) and (length(wrkstr)>0) do delete(wrkstr,1,1);
  if length(wrkstr)>0 then docommand(wrkstr);
  CommandDone:=true;
 end;

if CommandDone=false then AvlLngError(1,Command);
end;

procedure list;
var p,p1: pointer;
    i: longint;
begin
 getmem(P,65535);
 getmem(P1,65535);
 getimage(0,0,639,200,p^);
 getimage(0,201,639,400,p1^);
   SetFillStyle(1,black);
   Bar(0,0,639,400);
   setcolor(15);
   i:=0;
   if LastMacro>0 then
    begin
     for i:=0 to LastMacro-1 do if i*10<350 then
       outtextxy(1,i*10,SavedMacroses[i,0]+'   =   '+SavedMacroses[i,1]);
    end else outtextxy(1,i*10,'No macroses defined.');
   outtextxy(1,i*10+20,'Press any key');
   readkey;
   while keypressed do readkey;
 putimage(0,0,p^,normalput);
 putimage(0,201,p1^,normalput);
 freemem(P,65535);
 freemem(P1,65535);
end;

procedure help;
var p,p1: pointer;
    i: longint;
begin
 getmem(P,65535);
 getmem(P1,65535);
 getimage(0,0,639,200,p^);
 getimage(0,201,639,400,p1^);
 SetFillStyle(1,black);
 Bar(0,0,639,400);

outtextxy(1,0, '                STANDART TURTLE LANGUAGE COMMANDS:');
outtextxy(1,20,'left n                           turn left by n degrees');
outtextxy(1,30,'right n                          turn right by n degrees');
outtextxy(1,40,'forwards n                       move forward by n units');
outtextxy(1,50,'up                               lift the pen up ( stop drawing)');
outtextxy(1,60,'down                             put the pen down (continue drawing)');
outtextxy(1,70,'macro m = command: command:_     define macros');
outtextxy(1,80,'repeat m command                 Repeat the command or macro m times');
outtextxy(1,100,'To explain the macro and repeat command, we redo the above example:');
outtextxy(1,120,'macro drawandturn = forward 10: left 90');
outtextxy(1,130,'macro square = repeat 4 drawandturn');
outtextxy(1,160,'               FEW OTHER COMMAND:');
outtextxy(1,170,'load filename                   Run turtle program from file filename');
outtextxy(1,180,'clear                           Clear screen');
outtextxy(1,190,'help                            Output this help screen');
outtextxy(1,200,'list                            Output macros list (like this help)');
outtextxy(1,210,'nomacro                         Clean macros list. Run this after LOAD');
outtextxy(1,220,'exit                            Exit to DOS');
outtextxy(1,240,'               EXAMPLE:');
outtextxy(1,250,'load wheel.avl                  Try this. Load wheel.avl turtle program');
outtextxy(1,260,'load larkin.avl                 Try this. Load turtle language program');
outtextxy(1,300,'               REACH AUTHOR:');
outtextxy(1,310,'This program created by Alexander Larkin.');
outtextxy(1,320,'E-mail:             Larkin@titov.msk.ru');
outtextxy(1,330,'Internet address:   http://www.geocities.com/SiliconValley/6235/tpdl.htm');
outtextxy(1,390,'Press any key to return to program.');

 readkey;
 while keypressed do readkey;
 putimage(0,0,p^,normalput);
 putimage(0,201,p1^,normalput);
 freemem(P,65535);
 freemem(P1,65535);
end;

procedure DrawBorder;
 Begin
  rectangle (0,0,639,400);
  rectangle (1,1,638,399);
  OutTexTXY(0,410, '>>');
  OutTextXY(0,470,'exit Û help Û list Û load Û nomacro Û clear');
 end;

{Procedures}
procedure EraseScript;
   Begin
   SetFillStyle(1,black);
   Bar (17,410,640,419);
   end;

procedure showstr(s: string ) ; {Clear the box and redraw the string }
begin
  EraseScript;  {should have bitmap to clear this area of screen area}
  SetColor (White); SetTExtStyle(0, HorizDir,1);
  OutTextXY (17,410,s+'_');
end;

function myreadln : string;
var
   s : string;
   s1 : string;
   c : char;
begin
  s := '';
  showstr('');

  c := readkey;
  while (ord(c) <> 13 ) do
  begin
    if (ord(c) = 8) then
    begin
      s1 := copy( s, 1,length(s) - 1 );
      s:='';
      s :=s1;
    end else
    if c>=#32 then s := s + c ;
    showstr(s);
    c := readkey;
  end;
  myreadln:=s;
end;

procedure loadf(s: string);
var f: text;
    s1: string;
begin
if s<>'' then if s[1]=' ' then delete(s,1,1);
if s<>'' then if s[1]=' ' then delete(s,1,1);
 assign(f,s);
 {$I-}
 reset(f);
 {$I+}
   if ioresult=0 then
    begin
     repeat
      if drwcan then clear_turtle;
      readln(f,ReadFromFile);
      docommand(ReadFromFile);
      StringNumber:=StringNumber+1;
     until eof(f);
      if drwcan then clear_turtle;
     close(f);
    end else AvlLngError(4,'File not found!');
end;

begin
 drwcan:=true;
 DegreeAngle:=0;
 StringNumber:=0;
 x:=320;
 y:=240;
 LastMacro:=0;
 grDriver := Detect;
 InitGraph(grDriver, grMode,' ');
 ErrCode := GraphResult;
 if ErrCode = grOk then
 begin  { Do graphics }
 getmem(bg,1000);
 drawborder;
 draw_turtle;
  repeat
   StringNumber:=StringNumber+1;
   DrawBorder;
   if drwcan then clear_turtle;
   if drwcan then draw_turtle;
   SetFillStyle(1,black);
   Bar (1,460,640,470);
   outtextxy(1,460,'X-> '+strr(x)+'   Y-> '+strr(y)+'  Angle-> '+strr(DegreeAngle));
   ReadFromFile:=myreadln;
   s:=ReadFromFile;
   if Length(s)>4 then Delete(s,5,length(s)-4);
   if s='load' then Delete(ReadFromFile,1,4);
   if ReadFromFile='list' then list else
   if ReadFromFile='nomacro' then LastMacro:=0 else
   if ReadFromFile='clear' then
    begin
     if drwcan then clear_turtle;
     ClearDevice;
    end else
   if ReadFromFile='help' then help else
   if s='load' then loadf(ReadFromFile) else
   if (ReadFromFile<>'exit') and
   (ReadFromFile<>'EXIT') then docommand(ReadFromFile);
   if erris then erris:=false;
  until (ReadFromFile='exit') or (ReadFromFile='EXIT');
  freemem(bg,1000);
  closegraph;
 end
 else
   Writeln('Graphics error:', GraphErrorMsg(ErrCode));

end.



